home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _784aaea48b75eb74d28cc86624735816 < prev    next >
Encoding:
Text File  |  2002-05-30  |  10.0 KB  |  415 lines
  1. # Conversion from Tk4.0 scrollbar.tcl competed.
  2. package Tk::Scrollbar;
  3. require Tk;
  4. import Tk qw($XS_VERSION);
  5. use AutoLoader;
  6.  
  7. use vars qw($VERSION);
  8. $VERSION = '3.014'; # $Id: //depot/Tk8/Scrollbar/Scrollbar.pm#14 $
  9.  
  10. use base  qw(Tk::Widget);
  11.  
  12. Construct Tk::Widget 'Scrollbar';
  13.  
  14. bootstrap Tk::Scrollbar;
  15.  
  16. sub Tk_cmd { \&Tk::scrollbar }
  17.  
  18. Tk::Methods('activate','delta','fraction','get','identify','set');
  19.  
  20. sub Needed
  21. {
  22.  my ($sb) = @_;
  23.  my @val = $sb->get;
  24.  return 1 unless (@val == 2);
  25.  return 1 if $val[0] != 0.0;
  26.  return 1 if $val[1] != 1.0;
  27.  return 0;
  28. }
  29.  
  30.  
  31. sub ClassInit
  32. {
  33.  my ($class,$mw) = @_;
  34.  $mw->bind($class, '<Enter>', 'Enter');
  35.  $mw->bind($class, '<Motion>', 'Motion');
  36.  $mw->bind($class, '<Leave>', 'Leave');
  37.  
  38.  $mw->bind($class, '<1>', 'ButtonDown');
  39.  $mw->bind($class, '<B1-Motion>', 'Drag');
  40.  $mw->bind($class, '<ButtonRelease-1>', 'ButtonUp');
  41.  $mw->bind($class, '<B1-Leave>', 'NoOp'); # prevent generic <Leave>
  42.  $mw->bind($class, '<B1-Enter>', 'NoOp'); # prevent generic <Enter>
  43.  $mw->bind($class, '<Control-1>', 'ScrlTopBottom');
  44.  
  45.  $mw->bind($class, '<2>', 'ButtonDown');
  46.  $mw->bind($class, '<B2-Motion>', 'Drag');
  47.  $mw->bind($class, '<ButtonRelease-2>', 'ButtonUp');
  48.  $mw->bind($class, '<B2-Leave>', 'NoOp'); # prevent generic <Leave>
  49.  $mw->bind($class, '<B2-Enter>', 'NoOp'); # prevent generic <Enter>
  50.  $mw->bind($class, '<Control-2>', 'ScrlTopBottom');
  51.  
  52.  $mw->bind($class, '<Up>',            ['ScrlByUnits','v',-1]);
  53.  $mw->bind($class, '<Down>',          ['ScrlByUnits','v', 1]);
  54.  $mw->bind($class, '<Control-Up>',    ['ScrlByPages','v',-1]);
  55.  $mw->bind($class, '<Control-Down>',  ['ScrlByPages','v', 1]);
  56.  
  57.  $mw->bind($class, '<Left>',          ['ScrlByUnits','h',-1]);
  58.  $mw->bind($class, '<Right>',         ['ScrlByUnits','h', 1]);
  59.  $mw->bind($class, '<Control-Left>',  ['ScrlByPages','h',-1]);
  60.  $mw->bind($class, '<Control-Right>', ['ScrlByPages','h', 1]);
  61.  
  62.  $mw->bind($class, '<Prior>',         ['ScrlByPages','hv',-1]);
  63.  $mw->bind($class, '<Next>',          ['ScrlByPages','hv', 1]);
  64.  
  65.  $mw->bind($class, '<Home>',          ['ScrlToPos', 0]);
  66.  $mw->bind($class, '<End>',           ['ScrlToPos', 1]);
  67.  
  68.  return $class;
  69.  
  70. }
  71.  
  72. 1;
  73.  
  74. __END__
  75.  
  76. sub Enter
  77. {
  78.  my $w = shift;
  79.  my $e = $w->XEvent;
  80.  if ($Tk::strictMotif)
  81.   {
  82.    my $bg = $w->cget('-background');
  83.    $activeBg = $w->cget('-activebackground');
  84.    $w->configure('-activebackground' => $bg);
  85.   }
  86.  $w->activate($w->identify($e->x,$e->y));
  87. }
  88.  
  89. sub Leave
  90. {
  91.  my $w = shift;
  92.  if ($Tk::strictMotif)
  93.   {
  94.    $w->configure('-activebackground' => $activeBg) if (defined $activeBg) ;
  95.   }
  96.  $w->activate('');
  97. }
  98.  
  99. sub Motion
  100. {
  101.  my $w = shift;
  102.  my $e = $w->XEvent;
  103.  $w->activate($w->identify($e->x,$e->y));
  104. }
  105.  
  106. # tkScrollButtonDown --
  107. # This procedure is invoked when a button is pressed in a scrollbar.
  108. # It changes the way the scrollbar is displayed and takes actions
  109. # depending on where the mouse is.
  110. #
  111. # Arguments:
  112. # w -        The scrollbar widget.
  113. # x, y -    Mouse coordinates.
  114.  
  115. sub ButtonDown
  116. {my $w = shift;
  117.  my $e = $w->XEvent;
  118.  my $element = $w->identify($e->x,$e->y);
  119.  $w->configure('-activerelief' => 'sunken');
  120.  if ($e->b == 1 and
  121.      (defined($element) && $element eq 'slider'))
  122.   {
  123.    $w->StartDrag($e->x,$e->y);
  124.   }
  125.  elsif ($e->b == 2 and
  126.     (defined($element) && $element =~ /^(trough[12]|slider)$/o))
  127.   {
  128.     my $pos = $w->fraction($e->x, $e->y);
  129.     my($head, $tail) = $w->get;
  130.     my $len = $tail - $head;
  131.  
  132.     $head = $pos - $len/2;
  133.     $tail = $pos + $len/2;
  134.     if ($head < 0) {
  135.         $head = 0;
  136.         $tail = $len;
  137.     }
  138.     elsif ($tail > 1) {
  139.         $head = 1 - $len;
  140.         $tail = 1;
  141.     }
  142.     $w->ScrlToPos($head);
  143.     $w->set($head, $tail);
  144.  
  145.     $w->StartDrag($e->x,$e->y);
  146.    }
  147.  else
  148.   {
  149.    $w->Select($element,'initial');
  150.   }
  151. }
  152.  
  153. # tkScrollButtonUp --
  154. # This procedure is invoked when a button is released in a scrollbar.
  155. # It cancels scans and auto-repeats that were in progress, and restores
  156. # the way the active element is displayed.
  157. #
  158. # Arguments:
  159. # w -        The scrollbar widget.
  160. # x, y -    Mouse coordinates.
  161.  
  162. sub ButtonUp
  163. {my $w = shift;
  164.  my $e = $w->XEvent;
  165.  $w->CancelRepeat;
  166.  $w->configure('-activerelief' => 'raised');
  167.  $w->EndDrag($e->x,$e->y);
  168.  $w->activate($w->identify($e->x,$e->y));
  169. }
  170.  
  171. # tkScrollSelect --
  172. # This procedure is invoked when button 1 is pressed over the scrollbar.
  173. # It invokes one of several scrolling actions depending on where in
  174. # the scrollbar the button was pressed.
  175. #
  176. # Arguments:
  177. # w -        The scrollbar widget.
  178. # element -    The element of the scrollbar that was selected, such
  179. #        as "arrow1" or "trough2".  Shouldn't be "slider".
  180. # repeat -    Whether and how to auto-repeat the action:  "noRepeat"
  181. #        means don't auto-repeat, "initial" means this is the
  182. #        first action in an auto-repeat sequence, and "again"
  183. #        means this is the second repetition or later.
  184.  
  185. sub Select
  186. {
  187.  my $w = shift;
  188.  my $element = shift;
  189.  my $repeat  = shift;
  190.  return unless defined ($element);
  191.  if ($element eq 'arrow1')
  192.   {
  193.    $w->ScrlByUnits('hv',-1);
  194.   }
  195.  elsif ($element eq 'trough1')
  196.   {
  197.    $w->ScrlByPages('hv',-1);
  198.   }
  199.  elsif ($element eq 'trough2')
  200.   {
  201.    $w->ScrlByPages('hv', 1);
  202.   }
  203.  elsif ($element eq 'arrow2')
  204.   {
  205.    $w->ScrlByUnits('hv', 1);
  206.   }
  207.  else
  208.   {
  209.    return;
  210.   }
  211.  
  212.  if ($repeat eq 'again')
  213.   {
  214.    $w->RepeatId($w->after($w->cget('-repeatinterval'),['Select',$w,$element,'again']));
  215.   }
  216.  elsif ($repeat eq 'initial')
  217.   {
  218.    $w->RepeatId($w->after($w->cget('-repeatdelay'),['Select',$w,$element,'again']));
  219.   }
  220. }
  221.  
  222. # tkScrollStartDrag --
  223. # This procedure is called to initiate a drag of the slider.  It just
  224. # remembers the starting position of the slider.
  225. #
  226. # Arguments:
  227. # w -        The scrollbar widget.
  228. # x, y -    The mouse position at the start of the drag operation.
  229.  
  230. sub StartDrag
  231. {my $w = shift;
  232.  my $x = shift;
  233.  my $y = shift;
  234.  return unless (defined ($w->cget('-command')));
  235.  $initMouse  = $w->fraction($x,$y);
  236.  @initValues = $w->get();
  237.  if (@initValues == 2)
  238.   {
  239.    $initPos = $initValues[0];
  240.   }
  241.  else
  242.   {
  243.    $initPos = $initValues[2] / $initValues[0];
  244.   }
  245. }
  246.  
  247. # tkScrollDrag --
  248. # This procedure is called for each mouse motion even when the slider
  249. # is being dragged.  It notifies the associated widget if we're not
  250. # jump scrolling, and it just updates the scrollbar if we are jump
  251. # scrolling.
  252. #
  253. # Arguments:
  254. # w -        The scrollbar widget.
  255. # x, y -    The current mouse position.
  256.  
  257. sub Drag
  258. {my $w = shift;
  259.  my $e = $w->XEvent;
  260.  return unless (defined $initMouse);
  261.  my $f = $w->fraction($e->x,$e->y);
  262.  my $delta = $f - $initMouse;
  263.  if ($w->cget('-jump'))
  264.   {
  265.    if (@initValues == 2)
  266.     {
  267.      $w->set($initValues[0]+$delta,$initValues[1]+$delta);
  268.     }
  269.    else
  270.     {
  271.      $delta = int($delta * $initValues[0]);
  272.      $initValues[2] += $delta;
  273.      $initValues[3] += $delta;
  274.      $w->set(@initValues);
  275.     }
  276.   }
  277.  else
  278.   {
  279.    $w->ScrlToPos($initPos+$delta);
  280.   }
  281. }
  282.  
  283. # tkScrollEndDrag --
  284. # This procedure is called to end an interactive drag of the slider.
  285. # It scrolls the window if we're in jump mode, otherwise it does nothing.
  286. #
  287. # Arguments:
  288. # w -        The scrollbar widget.
  289. # x, y -    The mouse position at the end of the drag operation.
  290.  
  291. sub EndDrag
  292. {
  293.  my $w = shift;
  294.  my $x = shift;
  295.  my $y = shift;
  296.  return unless defined($initMouse);
  297.  if ($w->cget('-jump'))
  298.   {
  299.    $w->ScrlToPos($initPos + $w->fraction($x,$y) - $initMouse);
  300.   }
  301.  undef $initMouse;
  302. }
  303.  
  304. # tkScrlByUnits --
  305. # This procedure tells the scrollbar's associated widget to scroll up
  306. # or down by a given number of units.  It notifies the associated widget
  307. # in different ways for old and new command syntaxes.
  308. #
  309. # Arguments:
  310. # w -        The scrollbar widget.
  311. # orient -    Which kinds of scrollbars this applies to:  "h" for
  312. #        horizontal, "v" for vertical, "hv" for both.
  313. # amount -    How many units to scroll:  typically 1 or -1.
  314.  
  315. sub ScrlByUnits
  316. {my $w = shift;
  317.  my $orient = shift;
  318.  my $amount = shift;
  319.  my $cmd    = $w->cget('-command');
  320.  return unless (defined $cmd);
  321.  return if (index($orient,substr($w->cget('-orient'),0,1)) < 0);
  322.  my @info = $w->get;
  323.  if (@info == 2)
  324.   {
  325.    $cmd->Call('scroll',$amount,'units');
  326.   }
  327.  else
  328.   {
  329.    $cmd->Call($info[2]+$amount);
  330.   }
  331. }
  332.  
  333. # tkScrlByPages --
  334. # This procedure tells the scrollbar's associated widget to scroll up
  335. # or down by a given number of screenfuls.  It notifies the associated
  336. # widget in different ways for old and new command syntaxes.
  337. #
  338. # Arguments:
  339. # w -        The scrollbar widget.
  340. # orient -    Which kinds of scrollbars this applies to:  "h" for
  341. #        horizontal, "v" for vertical, "hv" for both.
  342. # amount -    How many screens to scroll:  typically 1 or -1.
  343.  
  344. sub ScrlByPages
  345. {
  346.  my $w = shift;
  347.  my $orient = shift;
  348.  my $amount = shift;
  349.  my $cmd    = $w->cget('-command');
  350.  return unless (defined $cmd);
  351.  return if (index($orient,substr($w->cget('-orient'),0,1)) < 0);
  352.  my @info = $w->get;
  353.  if (@info == 2)
  354.   {
  355.    $cmd->Call('scroll',$amount,'pages');
  356.   }
  357.  else
  358.   {
  359.    $cmd->Call($info[2]+$amount*($info[1]-1));
  360.   }
  361. }
  362.  
  363. # tkScrlToPos --
  364. # This procedure tells the scrollbar's associated widget to scroll to
  365. # a particular location, given by a fraction between 0 and 1.  It notifies
  366. # the associated widget in different ways for old and new command syntaxes.
  367. #
  368. # Arguments:
  369. # w -        The scrollbar widget.
  370. # pos -        A fraction between 0 and 1 indicating a desired position
  371. #        in the document.
  372.  
  373. sub ScrlToPos
  374. {
  375.  my $w = shift;
  376.  my $pos = shift;
  377.  my $cmd = $w->cget('-command');
  378.  return unless (defined $cmd);
  379.  my @info = $w->get;
  380.  if (@info == 2)
  381.   {
  382.    $cmd->Call('moveto',$pos);
  383.   }
  384.  else
  385.   {
  386.    $cmd->Call(int($info[0]*$pos));
  387.   }
  388. }
  389.  
  390. # tkScrlTopBottom
  391. # Scroll to the top or bottom of the document, depending on the mouse
  392. # position.
  393. #
  394. # Arguments:
  395. # w -        The scrollbar widget.
  396. # x, y -    Mouse coordinates within the widget.
  397.  
  398. sub ScrlTopBottom
  399. {
  400.  my $w = shift;
  401.  my $e = $w->XEvent;
  402.  my $element = $w->identify($e->x,$e->y);
  403.  return unless ($element);
  404.  if ($element =~ /1$/)
  405.   {
  406.    $w->ScrlToPos(0);
  407.   }
  408.  elsif ($element =~ /2$/)
  409.   {
  410.    $w->ScrlToPos(1);
  411.   }
  412. }
  413.  
  414.  
  415.